Clear[initialcrossing,initialmatrix,braidword,Quad, A, F, HigherOrder,kerbeforesub,keraftersub,exp2,poly,poly2,tr,knot,n,p1,p2,p3,p4]

knot={9,14};
f[{i_,n_}]:=If[n>0,ConstantArray[{i,i+1},{n}],ConstantArray[{i+1,i},{-n}]]
list=Flatten[f/@KnotData[knot,"BraidWord"]];
initialcrossing=firstcrossing[Take[list,{1,2}]];
initialmatrix=firstmatrix[Take[list,{1,2}]];
braidword=Sequence[Partition[Take[list,2-Length[list]],2]];
n=KnotData[knot,"BraidIndex"];
firstcrossing[{x_,y_}]:=If[x<y,(Subscript[HO, x,y]),(Subscript[INV, y,x])] ;
firstmatrix[{x_,y_}]:= If[x<y,(Subscript[Matrix, x,y]),(Subscript[Imatrix, y,x])];
alex=KnotData[knot,"AlexanderPolynomial"][t^2];
amp=KnotData[knot,"Amphichiral"];
rep2[i_,j_]:=Which[i==j==0,1,True,((i!j!Coefficient[exp2,(Subscript[d, 2])^i (Subscript[z, 2])^j ])/.{(Subscript[z, 2])->0,(Subscript[d, 2])->0})]
rep3[i_,j_,k_,l_]:=Which[i==j==k==l==0,1,True,((i!j!k!l!Coefficient[exp2,(Subscript[d, 2])^i (Subscript[z, 2])^j (Subscript[d, 3 ])^k (Subscript[z, 3])^l])/.{(Subscript[z, 2])->0,(Subscript[d, 2])->0,(Subscript[z, 3])->0,(Subscript[d, 3])->0})]
rep4[i_,j_,k_,l_,m_,n_]:=Which[i==j==k==l==m==n==0,1,True,((i!j!k!l!m!n!Coefficient[exp2,(Subscript[d, 2])^i (Subscript[z, 2])^j (Subscript[d, 3 ])^k (Subscript[z, 3])^l (Subscript[d, 4 ])^m (Subscript[z, 4])^n])/.{(Subscript[z, 2])->0,(Subscript[d, 2])->0,(Subscript[z, 3])->0,(Subscript[d, 3])->0,(Subscript[z, 4])->0,(Subscript[d, 4])->0})]
rep5[i_,j_,k_,l_,m_,n_,o_,p_]:=Which[i==j==k==l==m==n==o==p==0,1,True,((i!j!k!l!m!n!o!p!Coefficient[exp2,(Subscript[d, 2])^i (Subscript[z, 2])^j (Subscript[d, 3 ])^k (Subscript[z, 3])^l (Subscript[d, 4 ])^m (Subscript[z, 4])^n (Subscript[d, 5 ])^o (Subscript[z, 5])^p])/.{(Subscript[z, 2])->0,(Subscript[d, 2])->0,(Subscript[z, 3])->0,(Subscript[d, 3])->0,(Subscript[z, 4])->0,(Subscript[d, 4])->0,(Subscript[z, 5])->0,(Subscript[d, 5])->0})]
rep6[i_,j_,k_,l_,m_,n_,o_,p_,q_,r_]:=Which[i==j==k==l==m==n==o==p==q==r==0,1,True,((i!j!k!l!m!n!o!p!q!r!Coefficient[exp2,(Subscript[d, 2])^i (Subscript[z, 2])^j (Subscript[d, 3 ])^k (Subscript[z, 3])^l (Subscript[d, 4 ])^m (Subscript[z, 4])^n (Subscript[d, 5 ])^o (Subscript[z, 5])^p (Subscript[d, 6])^q (Subscript[z, 6])^r])/.{(Subscript[z, 2])->0,(Subscript[d, 2])->0,(Subscript[z, 3])->0,(Subscript[d, 3])->0,(Subscript[z, 4])->0,(Subscript[d, 4])->0,(Subscript[z, 5])->0,(Subscript[d, 5])->0,(Subscript[z, 6])->0,(Subscript[d, 6])->0})]
(Subscript[trace, 2])[s_]:=Expand[Plus@@(s/.Rule[{a_,b_},c_]:>rep2[a,b]c)]
(Subscript[trace, 3])[s_]:=Expand[Plus@@(s/.Rule[{a_,b_,e_,f_},c_]:>rep3[a,b,e,f]c)]
(Subscript[trace, 4])[s_]:=Expand[Plus@@(s/.Rule[{a_,b_,e_,f_,g_,h_},c_]:>rep4[a,b,e,f,g,h]c)]
(Subscript[trace, 5])[s_]:=Expand[Plus@@(s/.Rule[{a_,b_,e_,f_,g_,h_,i_,j_},c_]:>rep5[a,b,e,f,g,h,i,j]c)]
(Subscript[trace, 6])[s_]:=Expand[Plus@@(s/.Rule[{a_,b_,e_,f_,g_,h_,i_,j_,k_,l_},c_]:>rep6[a,b,e,f,g,h,i,j,k,l]c)]
qh[n_]:=(1+h Coefficient[Product[1+2h (Subscript[z, i])(Subscript[d, i]),{i,2,n}],h,1])
(Subscript[p, l_,k_])[i_,j_]:=Which[i==k&&j==l,t,i==l&&j==k,t,i==j==l,0,i==j==k,1-t^2,i==j,1,True,0];
(Subscript[Matrix, l_,k_]):=Array[(Subscript[p, l,k]),{n,n}];
(Subscript[Imatrix, l_,k_]):=Inverse[(Subscript[Matrix, l,k])];
(Subscript[Sz, l_,k_])[(Subscript[z, j_])]:=Expand[Sum[(Subscript[z, i])(Subscript[Imatrix, l,k])[[i,j]],{i,1,n}]];
(Subscript[Sder, l_,k_])[(Subscript[d, j_])]:=Expand[Sum[(Subscript[Matrix, l,k])[[i,j]](Subscript[d, i]),{i,1,n}]];
(Subscript[ISz, l_,k_])[(Subscript[z, j_])]:=Expand[Sum[(Subscript[z, i])(Subscript[Matrix, l,k])[[i,j]],{i,1,n}]];
(Subscript[ISder, l_,k_])[(Subscript[d, j_])]:=Expand[Sum[(Subscript[Imatrix, l,k])[[i,j]](Subscript[d, i]),{i,1,n}]];
Higher[a_,b_,w_,x_]:=1+h (2 a b w x-((2 (a^2) w x)/t)+2 (a^2) t w x+3 (a^2) (x^2)-(((a^2) (x^2))/(t^2))+((a b (x^2))/t)-3 a b t (x^2)-2 (a^2) (t^2) (x^2))
Inv[a_,b_,w_,x_]:=1+h ((b^2)*(w^2)-(t^2) (b^2)*(w^2)+((a*b*(w^2))/t)+t a*b*(w^2)-2 a*b*w*x)

(Subscript[HO, i_,j_]):=Higher[(Subscript[z, i]),(Subscript[z, j]),(Subscript[d, i]),(Subscript[d, j])]
(Subscript[INV, i_,j_]):=Inv[(Subscript[z, i]),(Subscript[z, j]),(Subscript[d, i]),(Subscript[d, j])]
(Subscript[Der, i_])[f_]:=f+Sum[(1/k!)D[f,{(Subscript[w, i]),k},{(Subscript[x, i]),k}],{k,1,4}]
NO3[l_,{i_,j_}]/;i<j :=((Subscript[Der, j])[(Subscript[Der, i])[Expand[1+h Coefficient[((l/.Flatten[Table[{(Subscript[z, k])->(Subscript[Sz, i,j])[(Subscript[z, k])],(Subscript[d, k])->(Subscript[Sder, i,j])[(Subscript[d, k])]},{k,1,n}]])/.{(Subscript[d, i])->(Subscript[w, i]),(Subscript[d, j])->(Subscript[w, j])})*Higher[(Subscript[x, i]),(Subscript[x, j]),(Subscript[d, i]),(Subscript[d, j])],h,1]]]])/.{(Subscript[w, i])->(Subscript[d, i]),(Subscript[w, j])->(Subscript[d, j]),(Subscript[x, i])->(Subscript[z, i]),(Subscript[x, j])->(Subscript[z, j])}

NO3[l_,{i_,j_}]/;i>j:=((Subscript[Der, j])[(Subscript[Der, i])[Expand[1+h Coefficient[((l/.Flatten[Table[{(Subscript[z, k])->(Subscript[ISz, j,i])[(Subscript[z, k])],(Subscript[d, k])->(Subscript[ISder, j,i])[(Subscript[d, k])]},{k,1,n}]])/.{(Subscript[d, i])->(Subscript[w, i]),(Subscript[d, j])->(Subscript[w, j])})*Inv[(Subscript[x, j]),(Subscript[x, i]),(Subscript[d, j]),(Subscript[d, i])],h,1]]]])/.{(Subscript[w, i])->(Subscript[d, i]),(Subscript[w, j])->(Subscript[d, j]),(Subscript[x, i])->(Subscript[z, i]),(Subscript[x, j])->(Subscript[z, j])}


subd=Flatten[Table[(Subscript[d, i])->(Subscript[w, i]),{i,2,n}]];
subz=Flatten[Table[(Subscript[z, i])->(Subscript[x, i]),{i,2,n}]];

g[l_,{x_ ,y_}]:=If[x<y,l.((Subscript[Matrix, x,y])),l.((Subscript[Imatrix, y,x]))]

qhend3[f_]:=Expand[(f/.subd)+h (Coefficient[qh[n],h,1]/.subz)]

Quad=Expand[Fold[g,initialmatrix,braidword]];
(Subscript[a, i_,j_]):=If[i==j,Quad[[i,j]]-1,Quad[[i,j]]];
A=Table[(Subscript[a, i,j]),{i,2,n},{j,2,n}];
F=Inverse[-A];

initialcrossing

AbsoluteTiming[HigherOrder3=Fold[NO3,initialcrossing,braidword];]

AbsoluteTiming[kerbeforesub3=((l=qhend3[HigherOrder3];Do[l=(Subscript[Der, i])[l],{i,2,n,1}];l)/.Flatten[Table[{(Subscript[x, i])->(Subscript[z, i]),(Subscript[w, i])->(Subscript[d, i])},{i,2,n}]]);]

sub=Flatten[Table[(Subscript[z, k])->Expand[Sum[Quad[[i,k]] (Subscript[z, i]),{i,1,n}]],{k,1,n}]]

AbsoluteTiming[keraftersub=kerbeforesub3/.sub;]

sub3=Simplify[Collect[Flatten[Table[{(Subscript[z, i])->(Subscript[z, i])+Expand[Sum[F[[k,i-1]]Quad[[1,k+1]](Subscript[z, 1]),{k,1,n-1}]],(Subscript[d, i])->(Subscript[d, i])+Expand[Sum[F[[i-1,l]]Quad[[l+1,1]](Subscript[d, 1]),{l,1,n-1}]]},{i,2,n}]],{(Subscript[z, 1]),(Subscript[z, 2]),(Subscript[z, 3]),(Subscript[z, 4]),(Subscript[z, 5]),(Subscript[d, 1]),(Subscript[d, 2]),(Subscript[d, 3]),(Subscript[d, 4]),(Subscript[d, 5])}]]

AbsoluteTiming[twopoly=keraftersub/.sub3]

sub4=Sum[(Expand[Sum[F[[i-1,j-1]](Subscript[d, i])(Subscript[z , j]),{j,2,n},{i,2,n}]])^i/i!,{i,1,4}]

AbsoluteTiming[exp2=Expand[1+sub4];]

sub5=Flatten[Table[{(Subscript[d, i]),(Subscript[z, i])},{i,2,n}]]

AbsoluteTiming[poly2=CoefficientRules[twopoly,sub5]]

AbsoluteTiming[tr=(Subscript[trace, n])[poly2];]

test1=Together[Coefficient[tr,h,1]]

p=If[amp==True,Cancel[Denominator[test1]/alex],Cancel[Denominator[test1]/alex^2]]

series=If[amp==True,Normal[Series[((((1+h test1)(1/alex))/.{t->t Exp[h]})(alex)/.{h-> (h/2)})/.{h->Sqrt[1+h]-1/Sqrt[1+h]},{h,0,1}]],Normal[Series[((((1+h test1)(1/alex))/.{t->t Exp[h]})alex)/.{h-> (h/2)},{h,0,1}]]]

p1=Expand[Numerator[Coefficient[series,h,1]]/p]

SessionTime[]